home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1999 January / PC Plus Super CD No55a (PCP-147A-1-99) (Disc 1) (1998).iso / linux / developers / visualtcl / windows / vtcl / lib / compound.tcl < prev    next >
Encoding:
Text File  |  1998-02-01  |  9.7 KB  |  321 lines

  1. ##############################################################################
  2. # $Id: compound.tcl,v 1.10 1998/02/02 05:11:33 stewart Exp $
  3. #
  4. # compound.tcl - procedures for creating and inserting compound-widgets
  5. #
  6. # Copyright (C) 1996-1997 Stewart Allen
  7. #
  8. # This program is free software; you can redistribute it and/or
  9. # modify it under the terms of the GNU General Public License
  10. # as published by the Free Software Foundation; either version 2
  11. # of the License, or (at your option) any later version.
  12. #
  13. # This program is distributed in the hope that it will be useful,
  14. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. # GNU General Public License for more details.
  17. #
  18. # You should have received a copy of the GNU General Public License
  19. # along with this program; if not, write to the Free Software
  20. # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ##############################################################################
  23. #
  24.  
  25. ##########################################################################
  26. # Compound Widgets
  27. #
  28. # compound   = type options mgr-info bind-info children
  29. # mgr-info   = geom-manager-name geom-info
  30. # bind-info  = list of: {event} {command}
  31. # menu-info  = list of: {type} {options}
  32. # children   = list-of-compound-widgets (recursive)
  33. #
  34.  
  35. proc vTcl:save_compounds {} {
  36.     global vTcl
  37.     set file [vTcl:get_file save "Save Compound Library"]
  38.     if {$file == ""} {return}
  39.     set f [open $file w]
  40.     puts $f "set vTcl(cmpd,list) \"$vTcl(cmpd,list)\"\n"
  41.     set index 0
  42.     set num [llength $vTcl(cmpd,list)]
  43.     foreach i $vTcl(cmpd,list) {
  44.         puts $f "set \{vTcl(cmpd:$i)\} \{$vTcl(cmpd:$i)\}\n"
  45.         incr index
  46.         vTcl:statbar [expr ($index * 100) / $num]
  47.     }
  48.     close $f
  49.     vTcl:statbar 0
  50. }
  51.  
  52. proc vTcl:load_compounds {{file ""}} {
  53.     global vTcl
  54.     set file [vTcl:get_file open "Load Compound Library"]
  55.     if {$file == ""} {return}
  56.     vTcl:statbar 10
  57.     source $file
  58.     vTcl:statbar 80
  59.     vTcl:cmp_user_menu
  60.     vTcl:statbar 0
  61. }
  62.  
  63. proc vTcl:put_compound {compound} {
  64.     global vTcl
  65.     set name [vTcl:new_widget_name cpd $vTcl(w,insert)]
  66.     vTcl:insert_compound $name $compound $vTcl(w,def_mgr)
  67.     vTcl:setup_bind_tree $name
  68.     vTcl:active_widget $name
  69.     vTcl:update_proc_list
  70. }
  71.  
  72. proc vTcl:name_replace {name s} {
  73.     global vTcl
  74.     foreach i $vTcl(cmp,alias) {
  75.         set s [vTcl:replace [lindex $i 0] $name[lindex $i 1] $s]
  76.     }
  77.     return $s
  78. }
  79.  
  80. proc vTcl:insert_compound {name compound {gmgr pack} {gopt ""}} {
  81.     global vTcl
  82.     set cpd \{[lindex $compound 0]\}
  83.     set alias [lindex $compound 1]
  84.     set vTcl(cmp,alias) [lsort -decreasing -command vTcl:sort_cmd $alias]
  85.     set cmd [vTcl:extract_compound $name $name $cpd 0 $gmgr $gopt]
  86.     set do "$cmd"
  87.     set undo "destroy $name"
  88.     vTcl:push_action $do $undo
  89. }
  90.  
  91. proc vTcl:extract_compound {base name compound {level 0} {gmgr ""} {gopt ""}} {
  92.     global vTcl widget
  93.     set todo ""
  94.     foreach i $compound {
  95.         set type [string trim [lindex $i 0]]
  96.         set opts [string trim [lindex $i 1]]
  97.         set mgr  [string trim [lindex $i 2]]
  98.         set mgrt [string trim [lindex $mgr 0]]
  99.         set mgri [string trim [lindex $mgr 1]]
  100.         set bind [string trim [lindex $i 3]]
  101.         set menu [string trim [lindex $i 4]]
  102.         set chld [string trim [lindex $i 5]]
  103.         set wdgt [string trim [lindex $i 6]]
  104.         set alis [string trim [lindex $i 7]]
  105.         set grid [string trim [lindex $i 8]]
  106.         set proc [string trim [lindex $i 9]]
  107.         set cmpdname [string trim [lindex $i 10]]
  108.         set topopt [string trim [lindex $i 11]]
  109.         #
  110.         # process procs first in case there are dependancies (init)
  111.         #
  112.         foreach j $proc {
  113.             set nme [lindex $j 0]
  114.             set arg [lindex $j 1]
  115.             set bdy [lindex $j 2]
  116.             proc $nme $arg $bdy
  117.             vTcl:list add "{$nme}" vTcl(procs)
  118.             if {$nme == "${cmpdname}:init"} {
  119.                 eval $nme
  120.             }
  121.         }
  122.         if {$mgrt == "wm" || $base == "."} {
  123.             set base $name
  124.         } elseif {$level == 0 && $gmgr != ""} {
  125.             if {$gmgr != $mgrt || $gopt != ""}  {
  126.                 set mgrt $gmgr
  127.                 set mgri $gopt
  128.             }
  129.             if {$mgrt != "place"} {
  130.                 set mgri [lrange $mgri 2 end]
  131.             }
  132.         }
  133.         if {$level > 0} {
  134.             set name "$base$wdgt"
  135.         } elseif {$type == "toplevel"} {
  136.             set vTcl(w,insert) $name
  137.             lappend vTcl(tops) $name
  138.             vTcl:update_top_list
  139.         }
  140.         append todo "$type $name [vTcl:name_replace $base $opts]; "
  141.         if {$mgrt != "" && $mgrt != "wm"} {
  142.             if {$mgrt == "place" && $mgri == ""} {
  143.                 set mgri "-x 5 -y 5"
  144.             }
  145.             append todo "$mgrt $name [vTcl:name_replace $base $mgri]; "
  146.         } elseif {$mgrt == "wm"} {
  147.         } else {
  148.             set ret $name
  149.         }
  150.         foreach j $topopt {
  151.             set opt [lindex $j 0]
  152.             set val [lindex $j 1]
  153.             switch $opt {
  154.                 {} {}
  155.                 state {
  156.                 }
  157.                 title {
  158.                     append todo "wm $opt $name \"$val\"; "
  159.                 }
  160.                 default {
  161.                     append todo "wm $opt $name $val; "
  162.                 }
  163.             }
  164.         }
  165.         set index 0
  166.         incr level
  167.         foreach j $bind {
  168.             set e [lindex $j 0]
  169.             set c [vTcl:name_replace $base [lindex $j 1]]
  170.             append todo "bind $name $e \"$c\"; "
  171.         }
  172.         foreach j $menu {
  173.             set t [lindex $j 0]
  174.             set o [lindex $j 1]
  175.             if {$t != "tearoff"} {
  176.                 append todo "$name add $t $o; "
  177.             }
  178.         }
  179.         foreach j $chld {
  180.             append todo "[vTcl:extract_compound $base $name \{$j\} $level]; "
  181.             incr index
  182.         }
  183.         if {$alis != "" && ![llength [array get widget $alis]]} {
  184.             set widget($alis) $name
  185.             set widget(rev,$name) "$alis"
  186.         }
  187.         foreach j $grid {
  188.             set cmd [lindex $j 0]
  189.             set num [lindex $j 1]
  190.             set prop [lindex $j 2]
  191.             set val [lindex $j 3]
  192.             append todo "grid $cmd $name $num $prop $val; "
  193.         }
  194.         if {[info procs "${cmpdname}:main"] != ""} {
  195.             eval ${cmpdname}:main
  196.         }
  197.     }
  198.     return $todo
  199. }
  200.  
  201. proc vTcl:create_compound {target {cmpdname ""}} {
  202.     global vTcl
  203.     set vTcl(cmp,alias) ""
  204.     set vTcl(cmp,index) 0
  205.     set ret [vTcl:gen_compound $target "" $cmpdname]
  206.     lappend ret $vTcl(cmp,alias)
  207.     return $ret
  208. }
  209.  
  210. proc vTcl:gen_compound {target {name ""} {cmpdname ""}} {
  211.     global vTcl widget
  212.     set ret ""
  213.     set mgr ""
  214.     set bind ""
  215.     set menu ""
  216.     set chld ""
  217.     set alias ""
  218.     set grid ""
  219.     set proc ""
  220.     if {![winfo exists $target]} {
  221.         return ""
  222.     }
  223.     set type [vTcl:get_class $target 1]
  224.     set opts [vTcl:get_opts [$target conf]]
  225.     if {$type == "menu"} {
  226.         set mnum [$target index end]
  227.         if {$mnum != "none"} {
  228.             for {set i 0} {$i <= $mnum} {incr i} {
  229.                 set t [$target type $i]
  230.                 set c [vTcl:get_opts [$target entryconf $i]]
  231.                 lappend menu "$t \{$c\}"
  232.             }
  233.         }
  234.         set mgrt {}
  235.         set mgri {}
  236.     } elseif {$type == "toplevel"} {
  237.         set mgrt "wm"
  238.         set mgri ""
  239.     } else {
  240.         set mgrt [winfo manager $target]
  241.         set mgri [vTcl:get_mgropts [$mgrt info $target]]
  242.     }
  243.     lappend mgr $mgrt $mgri
  244.     set blst [bind $target]
  245.     foreach i $blst {
  246.         lappend bind "$i \{[bind $target $i]\}"
  247.     }
  248.     foreach i [vTcl:get_children $target] {
  249.         incr vTcl(cmp,index)
  250.         append chld "[vTcl:gen_compound $i $name.0$vTcl(cmp,index)] "
  251.     }
  252.     catch {set alias $widget(rev,$target)}
  253.     set pre g
  254.     set gcolumn [lindex [grid size $target] 0]
  255.     set grow [lindex [grid size $target] 1]
  256.     foreach a {column row} {
  257.         foreach b {weight minsize} {
  258.             set num [subst $$pre$a]
  259.             for {set i 0} {$i < $num} {incr i} {
  260.                 if [catch {
  261.                     set x [expr round([grid ${a}conf $target $i -$b])]
  262.                 }] {set x 0}
  263.                 if {$x > 0} {
  264.                     lappend grid "${a}conf $i -$b $x"
  265.                 }
  266.             }
  267.         }
  268.     }
  269.     if {$cmpdname != ""} {
  270.         foreach i $vTcl(procs) {
  271.             if [string match ${cmpdname}:* $i] {
  272.                 lappend proc [list $i [vTcl:proc:get_args $i] [info body $i]]
  273.             }
  274.         }
  275.     }
  276.     set topopt ""
  277.     if {$type == "toplevel"} {
  278.         foreach i $vTcl(attr,tops) {
  279.             set v [wm $i $target]
  280.             if {$v != ""} {
  281.                 lappend topopt [list $i $v]
  282.             }
  283.         }
  284.     }
  285.     lappend ret $type $opts $mgr $bind $menu $chld $name $alias $grid $proc $cmpdname $topopt
  286.     vTcl:append_alias $target $name
  287.     return \{$ret\}
  288. }
  289.  
  290. proc vTcl:append_alias {name alias} {
  291.     global vTcl
  292.     lappend vTcl(cmp,alias) "$name $alias"
  293. }
  294.  
  295. proc vTcl:sort_cmd {el1 el2} {
  296.     set l1 [string length [lindex $el1 0]]
  297.     set l2 [string length [lindex $el2 0]]
  298.     return [expr $l1 - $l2]
  299. }
  300.  
  301. proc vTcl:replace {target replace source} {
  302.     set ret ""
  303.     set where [string first $target $source]
  304.     if {$where < 0} {return $source}
  305.     set len [string length $target]
  306.     set before [string range $source 0 [expr $where - 1]]
  307.     set after [string range $source [expr $where + $len] end]
  308.     return "$before$replace$after"
  309. }
  310.  
  311. proc vTcl:name_compound {t} {
  312.     global vTcl
  313.     if {$t == "" || ![winfo exists $t]} {return}
  314.     set name [vTcl:get_string "Name Compound" $t]
  315.     if {$name == ""} {return}
  316.     if {[lsearch $vTcl(cmpd,list) $name] < 0} {lappend vTcl(cmpd,list) $name}
  317.     set vTcl(cmpd:$name) [vTcl:create_compound $t $name]
  318.     vTcl:cmp_user_menu
  319. }
  320.  
  321.